home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / package.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  23.0 KB  |  1,084 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19. */
  20.  
  21. /*
  22.     package.d
  23. */
  24.  
  25. #include "include.h"
  26.  
  27. #define    HASHCOEF    12345        /*  hashing coefficient  */
  28.  
  29. int check_type_or_symbol_string_package();
  30.  
  31. #define    INTERNAL    1
  32. #define    EXTERNAL    2
  33. #define    INHERITED    3
  34.  
  35. #define P_INTERNAL(x,j) ((x)->p.p_internal[(j) % (x)->p.p_internal_size])
  36. #define P_EXTERNAL(x,j) ((x)->p.p_external[(j) % (x)->p.p_external_size])
  37.  
  38.  
  39.  
  40.  
  41. bool
  42. member_string_equal(x, l)
  43. object x, l;
  44. {
  45.     for (;  type_of(l) == t_cons;  l = l->c.c_cdr)
  46.         if (string_equal(x, l->c.c_car))
  47.             return(TRUE);
  48.     return(FALSE);
  49. }
  50.  
  51. rehash_pack(ptab,n,m)
  52.      object **ptab;
  53.      int *n,m;
  54. { object *ntab;
  55.   object *tab = *ptab;
  56.   object l,ll;
  57.   int k,i;
  58.   i=0;
  59.   k = *n;
  60.  
  61.   ntab= AR_ALLOC(alloc_contblock,m,object);
  62.   *ptab = ntab;
  63.   *n=m;
  64.   while(i<m) ntab[i++]=Cnil;
  65.    for(i=0 ; i< k; i++)
  66.        for (l = tab[i];  type_of(l) == t_cons;)
  67.       {int j =pack_hash(l->c.c_car)%m;
  68.        ll=l->c.c_cdr;
  69.        l->c.c_cdr = ntab[j];
  70.        ntab[j]=l;
  71.        l=ll;
  72.      }}
  73.  
  74. /* some prime numbers suitable for package sizes */
  75.  
  76. static int package_sizes[]={
  77.   97,251, 509, 1021, 2039, 4093, 8191, 16381,
  78.   32749, 65521, 131071, 262139,   524287, 1048573};
  79.  
  80. suitable_package_size(n)
  81. {int *i=package_sizes;
  82.  if (n>= 1000000) return 1048573;
  83.  while(*i < n) { i++;}
  84.  return *i;}
  85.    
  86. /*
  87.     Make_package(n, ns, ul, isize , esize) makes a package with name n,
  88.     which must be a string or a symbol,
  89.     and nicknames ns, which must be a list of strings or symbols,
  90.     and uses packages in list ul, which must be a list of packages
  91.     or package names i.e. strings or symbols.
  92. */
  93. object
  94. make_package(n, ns, ul,isize,esize)
  95. object n, ns, ul;
  96. int isize,esize;
  97. {
  98.     object x, y;
  99.     int i;
  100.     vs_mark;
  101.  
  102.     if (type_of(n) == t_symbol) {
  103.         vs_push(alloc_simple_string(n->s.s_fillp));
  104.         vs_head->st.st_self = n->s.s_self;
  105.         n = vs_head;
  106.     }
  107.     if (find_package(n) != Cnil)
  108.         package_already(n);
  109.     x = alloc_object(t_package);
  110.     x->p.p_name = n;
  111.     x->p.p_nicknames = Cnil;
  112.     x->p.p_shadowings = Cnil;
  113.     x->p.p_uselist = Cnil;
  114.     x->p.p_usedbylist = Cnil;
  115.     x->p.p_internal = NULL;
  116.     x->p.p_external = NULL;
  117.     x->p.p_internal_size = (isize ? isize : suitable_package_size(200));
  118.     x->p.p_external_size = (esize ? esize : suitable_package_size(60));
  119.     x->p.p_internal_fp =0;   
  120.     x->p.p_external_fp =0;
  121.     
  122.     vs_push(x);
  123.     for (;  !endp(ns);  ns = ns->c.c_cdr) {
  124.         n = ns->c.c_car;
  125.         if (type_of(n) == t_symbol) {
  126.             vs_push(alloc_simple_string(n->s.s_fillp));
  127.             vs_head->st.st_self = n->s.s_self;
  128.             n = vs_head;
  129.         }
  130.         if (find_package(n) != Cnil) {
  131.             vs_reset;
  132.             package_already(n);
  133.         }
  134.         x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
  135.     }
  136.     for (;  !endp(ul);  ul = ul->c.c_cdr) {
  137.         if (type_of(ul->c.c_car) == t_package)
  138.             y = ul->c.c_car;
  139.         else {
  140.             y = find_package(ul->c.c_car);
  141.             if (y == Cnil)
  142.                 no_package(ul->c.c_car);
  143.         }
  144.         x->p.p_uselist = make_cons(y, x->p.p_uselist);
  145.         y->p.p_usedbylist = make_cons(x, y->p.p_usedbylist);
  146.     }
  147.     x->p.p_internal
  148.     = AR_ALLOC(alloc_contblock,x->p.p_internal_size,object);
  149.     for (i = 0;  i < x->p.p_internal_size;  i++)
  150.         x->p.p_internal[i] = Cnil;
  151.     x->p.p_external
  152.     = AR_ALLOC(alloc_contblock,x->p.p_external_size,object);
  153.     for (i = 0;  i < x->p.p_external_size;  i++)
  154.         x->p.p_external[i] = Cnil;
  155.     x->p.p_link = pack_pointer;
  156.     pack_pointer = &(x->p);
  157.     vs_reset;
  158.     return(x);
  159. }
  160.  
  161. object
  162. in_package(n, ns, ul,isize,esize)
  163. object n, ns, ul;
  164. int isize,esize;
  165. {
  166.     object x, y;
  167.     int i;
  168.     vs_mark;
  169.  
  170.     x = find_package(n);
  171.     if (x == Cnil) {
  172.         x = make_package(n, ns, ul,isize,esize);
  173.         goto L;
  174.     }
  175.     if (isize) rehash_pack(&(x->p.p_internal),
  176.         &x->p.p_internal_size,isize);
  177.     for (;  !endp(ns);  ns = ns->c.c_cdr) {
  178.         n = ns->c.c_car;
  179.         if (type_of(n) == t_symbol) {
  180.             vs_push(alloc_simple_string(n->s.s_fillp));
  181.             vs_head->st.st_self = n->s.s_self;
  182.             n = vs_head;
  183.         }
  184.         y = find_package(n);
  185.         if (x == y)
  186.             continue;
  187.         if (y != Cnil)
  188.             package_already(n);
  189.         x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
  190.     }
  191.     for (;  !endp(ul);  ul = ul->c.c_cdr)
  192.         use_package(ul->c.c_car, x);
  193. L:
  194.     Vpackage->s.s_dbind = x;
  195.     vs_reset;
  196.     return(x);
  197. }
  198.  
  199. object
  200. rename_package(x, n, ns)
  201. object x, n, ns;
  202. {
  203.     object y;
  204.     vs_mark;
  205.  
  206.     if (type_of(n) == t_symbol) {
  207.         vs_push(alloc_simple_string(n->s.s_fillp));
  208.         vs_head->st.st_self = n->s.s_self;
  209.         n = vs_head;
  210.     }
  211.        if (!(equal(x->p.p_name,n)) &&
  212.         find_package(n) != Cnil)
  213.         package_already(n);
  214.     x->p.p_name = n;
  215.     x->p.p_nicknames = Cnil;
  216.     for (;  !endp(ns);  ns = ns->c.c_cdr) {
  217.         n = ns->c.c_car;
  218.         if (type_of(n) == t_symbol) {
  219.             vs_push(alloc_simple_string(n->s.s_fillp));
  220.             vs_head->st.st_self = n->s.s_self;
  221.             n = vs_head;
  222.         }
  223.         y = find_package(n);
  224.         if (x == y)
  225.             continue;
  226.         if (y != Cnil)
  227.             package_already(n);
  228.         x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
  229.     }
  230.     vs_reset;
  231.     return(x);
  232. }
  233.  
  234. /*
  235.     Find_package(n) seaches for a package with name n,
  236.     which is a string or a symbol.
  237.     If not so, an error is signaled.
  238. */
  239. object
  240. find_package(n)
  241. object n;
  242. {
  243.     struct package *p;
  244.  
  245.     if (type_of(n) == t_symbol)
  246.         ;
  247.     else if (type_of(n) != t_string)
  248.         FEwrong_type_argument(TSor_string_symbol, n);
  249.     for (p = pack_pointer;  p != NULL;  p = p->p_link) {
  250.         if (string_equal(p->p_name, n))
  251.             return((object)p);
  252.         if (member_string_equal(n, p->p_nicknames))
  253.             return((object)p);
  254.     }
  255.     return(Cnil);
  256. }
  257.  
  258. object
  259. coerce_to_package(p)
  260. object p;
  261. {
  262.     object pp;
  263.  
  264.     if (type_of(p) == t_package)
  265.         return(p);
  266.     pp = find_package(p);
  267.     if (pp == Cnil)
  268.         no_package(p);
  269.     return(pp);
  270. }
  271.  
  272. object
  273. current_package()
  274. {
  275.     object x;
  276.  
  277.     x = symbol_value(Vpackage);
  278.     if (type_of(x) != t_package) {
  279.         Vpackage->s.s_dbind = user_package;
  280.         FEerror("The value of *PACKAGE*, ~S, was not a package.",
  281.             1, x);
  282.     }
  283.     return(x);
  284. }
  285.  
  286. /*
  287.     Pack_hash(st) hashes string st
  288.     and returns the index for a hash table of a package.
  289. */
  290.  
  291. int
  292. pack_hash(x)
  293. object x;
  294. {unsigned int h=0;
  295.  {int len=x->st.st_fillp;
  296.   char *s;
  297. #define HADD(i,j,k,l) (h+=s[i],h+=s[j]<<8,h+=s[k]<<13,h+=s[l]<<23)
  298. #define HADD2(i,j) (h+=s[i]<<5,h+=s[j]<<15)
  299.   s=x->st.st_self;
  300.   switch(len) {
  301.   case 0: break;
  302.   case 10: 
  303.   case 9: HADD(1,4,6,8); HADD2(5,7); goto END;
  304.   case 8: HADD(1,3,5,7); HADD2(2,4); goto END;
  305.   case 7: HADD(1,3,4,5); HADD2(6,2); goto END;
  306.   case 6: HADD(1,3,4,5); HADD2(0,2); goto END;
  307.   case 5: h+= s[4] << 13;
  308.   case 4: h+= s[3] << 24;
  309.   case 3: h+= s[2]<< 16;
  310.   case 2: h+= s[1] << 8;
  311.   case 1: h+= s[0] ;
  312.     break;
  313.   default:
  314.     HADD(3,6,len-2,len-4); HADD2(1,len-1);
  315.     if (len > 15) {HADD2(7,10);           
  316.          }
  317.   }
  318.  END:
  319.   h &= 0x7fffffff; 
  320.   return(h);
  321. }}
  322.  
  323.  
  324.  
  325. /*
  326.     Intern(st, p) interns string st in package p.
  327. */
  328. object
  329. intern(st, p)
  330. object st, p;
  331. {
  332.     int j;
  333.     object x, *ip, *ep, l, ul;
  334.     vs_mark;
  335.  
  336.     j = pack_hash(st);
  337.     ip = &P_INTERNAL(p ,j);
  338. #define string_eq(a,b) \
  339.    ((a)->st.st_fillp==(b)->st.st_fillp && \
  340.      bcmp((a)->st.st_self,(b)->st.st_self,(a)->st.st_fillp)==0)
  341.  
  342.     for (l = *ip;  type_of(l) == t_cons;  l = l->c.c_cdr)
  343.         if (string_eq(l->c.c_car, st)) {
  344.             intern_flag = INTERNAL;
  345.             return(l->c.c_car);
  346.         }
  347.     ep = &P_EXTERNAL(p,j);
  348.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  349.         if (string_eq(l->c.c_car, st)) {
  350.             intern_flag = EXTERNAL;
  351.             return(l->c.c_car);
  352.         }
  353.     for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr)
  354.         for (l = P_EXTERNAL(ul->c.c_car,j);
  355.              type_of(l) == t_cons;
  356.              l = l->c.c_cdr)
  357.             if (string_eq(l->c.c_car, st)) {
  358.                 intern_flag = INHERITED;
  359.                 return(l->c.c_car);
  360.             }
  361.     x = make_symbol(st);
  362.     vs_push(x);
  363.     if (p == keyword_package) {
  364.         x->s.s_stype = (short)stp_constant;
  365.         x->s.s_dbind = x;
  366.         *ep = make_cons(x, *ep);
  367.         keyword_package->p.p_external_fp ++;
  368.         intern_flag = 0;
  369.     } else {
  370.         *ip = make_cons(x, *ip);
  371.         if (p->p.p_internal_fp++>(p->p.p_internal_size << 1))
  372.             rehash_pack(&(p->p.p_internal),&p->p.p_internal_size,
  373.                     suitable_package_size(p->p.p_internal_fp));
  374.         intern_flag = 0;
  375.     }
  376.     if (x->s.s_hpack == Cnil)
  377.         x->s.s_hpack = p;
  378.     vs_reset;
  379.     return(x);
  380. }
  381.  
  382. /*
  383.     Find_symbol(st, p) searches for string st in package p.
  384. */
  385. object
  386. find_symbol(st, p)
  387. object st, p;
  388. {
  389.     int j;
  390.     object *ip, *ep, l, ul;
  391.  
  392.     j = pack_hash(st);
  393.     ip = &P_INTERNAL(p ,j);
  394.     for (l = *ip;  type_of(l) == t_cons;  l = l->c.c_cdr)
  395.         if (string_eq(l->c.c_car, st)) {
  396.             intern_flag = INTERNAL;
  397.             return(l->c.c_car);
  398.         }
  399.     ep = &P_EXTERNAL(p,j);
  400.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  401.         if (string_eq(l->c.c_car, st)) {
  402.             intern_flag = EXTERNAL;
  403.             return(l->c.c_car);
  404.         }
  405.     for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr)
  406.         for (l = P_EXTERNAL(ul->c.c_car,j);
  407.              type_of(l) == t_cons;
  408.              l = l->c.c_cdr)
  409.             if (string_eq(l->c.c_car, st)) {
  410.                 intern_flag = INHERITED;
  411.                 return(l->c.c_car);
  412.             }
  413.     intern_flag = 0;
  414.     return(Cnil);
  415. }
  416.  
  417. bool
  418. unintern(s, p)
  419. object s, p;
  420. {
  421.     object x, y, l, *lp;
  422.     int j;
  423.  
  424.     j = pack_hash(s);
  425.     x = find_symbol(s, p);
  426.     if (intern_flag == INTERNAL && s == x) {
  427.         lp = &P_INTERNAL(p ,j);
  428.         if (member_eq(s, p->p.p_shadowings))
  429.             goto L;
  430.         goto UNINTERN;
  431.     }
  432.     if (intern_flag == EXTERNAL && s == x) {
  433.         lp = &P_EXTERNAL(p,j);
  434.         if (member_eq(s, p->p.p_shadowings))
  435.             goto L;
  436.         goto UNINTERN;
  437.     }
  438.     return(FALSE);
  439.  
  440. L:
  441.     x = OBJNULL;
  442.     for (l = p->p.p_uselist; type_of(l) == t_cons; l = l->c.c_cdr) {
  443.         y = find_symbol(s, l->c.c_car);
  444.         if (intern_flag == EXTERNAL) {
  445.             if (x == OBJNULL)
  446.                 x = y;
  447.             else if (x != y)
  448. FEerror("Cannot unintern the shadowing symbol ~S~%\
  449. from ~S,~%\
  450. because ~S and ~S will cause~%\
  451. a name conflict.", 4, s, p, x, y);
  452.         }
  453.     }
  454.     delete_eq(s, &p->p.p_shadowings);
  455.  
  456. UNINTERN:
  457.     delete_eq(s, lp);
  458.     if (s->s.s_hpack == p)
  459.         s->s.s_hpack = Cnil;
  460.     if ((enum stype)s->s.s_stype != stp_ordinary)
  461.         uninterned_list = make_cons(s, uninterned_list);
  462.     return(TRUE);
  463. }
  464.  
  465. export(s, p)
  466. object s, p;
  467. {
  468.     object x;
  469.     int j;
  470.     object *ep, *ip, l;
  471.  
  472. BEGIN:
  473.     ip = NULL;
  474.     j = pack_hash(s);
  475.     x = find_symbol(s, p);
  476.     if (intern_flag) {
  477.         if (x != s) {
  478.             import(s, p);    /*  signals an error  */
  479.             goto BEGIN;
  480.         }
  481.         if (intern_flag == INTERNAL)
  482.             ip = &P_INTERNAL(p ,j);
  483.         else if (intern_flag == EXTERNAL)
  484.             return;
  485.     } else
  486.         FEerror("The symbol ~S is not accessible from ~S.", 2,
  487.             s, p);
  488.     for (l = p->p.p_usedbylist;
  489.          type_of(l) == t_cons;
  490.          l = l->c.c_cdr) {
  491.         x = find_symbol(s, l->c.c_car);
  492.         if (intern_flag && s != x &&
  493.             !member_eq(x, l->c.c_car->p.p_shadowings))
  494. FEerror("Cannot export the symbol ~S~%\
  495. from ~S,~%\
  496. because it will cause a name conflict~%\
  497. in ~S.", 3, s, p, l->c.c_car);
  498.     }
  499.     if (ip != NULL)
  500.         {delete_eq(s, ip);
  501.          p->p.p_internal_fp--;}
  502.     ep = &P_EXTERNAL(p,j);
  503.     p->p.p_external_fp++;
  504.     *ep = make_cons(s, *ep);
  505. }
  506.  
  507. unexport(s, p)
  508. object s, p;
  509. {
  510.     object x, *ep, *ip;
  511.     int j;
  512.  
  513.     if (p == keyword_package)
  514.         FEerror("Cannot unexport a symbol from the keyword.", 0);
  515.     x = find_symbol(s, p);
  516.     if (intern_flag != EXTERNAL || x != s)
  517. FEerror("Cannot unexport the symbol ~S~%\
  518. from ~S,~%\
  519. because the symbol is not an external symbol~%\
  520. of the package.", 2, s, p);
  521.     j = pack_hash(s);
  522.     ep = &P_EXTERNAL(p,j);
  523.     delete_eq(s, ep);
  524.     ip = &P_INTERNAL(p ,j);
  525.     p->p.p_internal_fp++;
  526.     *ip = make_cons(s, *ip);
  527. }
  528.  
  529. import(s, p)
  530. object s, p;
  531. {
  532.     object x;
  533.     int j;
  534.     object *ip, l;
  535.  
  536.     x = find_symbol(s, p);
  537.     if (intern_flag) {
  538.         if (x != s)
  539. FEerror("Cannot import the symbol ~S~%\
  540. from ~S,~%\
  541. because there is already a symbol with the same name~%\
  542. in the package.", 2, s, p);
  543.         if (intern_flag == INTERNAL || intern_flag == EXTERNAL)
  544.             return;
  545.     }
  546.     j = pack_hash(s);
  547.     ip = &P_INTERNAL(p ,j);
  548.     p->p.p_internal_fp++;
  549.     *ip = make_cons(s, *ip);
  550. }
  551.  
  552. shadowing_import(s, p)
  553. object s, p;
  554. {
  555.     object x, *ip;
  556.  
  557.     x = find_symbol(s, p);
  558.     if (intern_flag && intern_flag != INHERITED) {
  559.         if (x == s) {
  560.             if (!member_eq(x, p->p.p_shadowings))
  561.                 p->p.p_shadowings
  562.                 = make_cons(x, p->p.p_shadowings);
  563.             return;
  564.         }
  565.         if(member_eq(x, p->p.p_shadowings))
  566.             delete_eq(x, &p->p.p_shadowings);
  567.         if (intern_flag == INTERNAL)
  568.             delete_eq(x, &P_INTERNAL(p,pack_hash(x)));
  569.         else
  570.             delete_eq(x, &P_EXTERNAL(p ,pack_hash(x)));
  571.         if (x->s.s_hpack == p)
  572.             x->s.s_hpack = Cnil;
  573.         if ((enum stype)x->s.s_stype != stp_ordinary)
  574.             uninterned_list = make_cons(x, uninterned_list);
  575.     }
  576.     ip = &P_INTERNAL(p ,pack_hash(s));
  577.     *ip = make_cons(s, *ip);
  578.     p->p.p_internal_fp++;    
  579.     p->p.p_shadowings = make_cons(s, p->p.p_shadowings);
  580. }
  581.  
  582. shadow(s, p)
  583. object s, p;
  584. {
  585.     int j;
  586.     object *ip;
  587.  
  588.     find_symbol(s, p);
  589.     if (intern_flag == INTERNAL || intern_flag == EXTERNAL)
  590.         return;
  591.     j = pack_hash(s);
  592.     ip = &P_INTERNAL(p ,j);
  593.     vs_push(make_symbol(s));
  594.     vs_head->s.s_hpack = p;
  595.     *ip = make_cons(vs_head, *ip);
  596.     p->p.p_internal_fp++;
  597.     p->p.p_shadowings = make_cons(vs_head, p->p.p_shadowings);
  598.     vs_pop;
  599. }
  600.  
  601. use_package(x0, p)
  602. object x0, p;
  603. {
  604.     object x = x0;
  605.     int i;
  606.     object y, l;
  607.  
  608.     if (type_of(x) != t_package) {
  609.         x = find_package(x);
  610.         if (x == Cnil)
  611.             no_package(x0);
  612.     }
  613.     if (x == keyword_package)
  614.         FEerror("Cannot use keyword package.", 0);
  615.     if (p == x)
  616.         return;
  617.     if (member_eq(x, p->p.p_uselist))
  618.         return;
  619.     for (i = 0;  i < x->p.p_external_size;  i++)
  620.         for (l = P_EXTERNAL(x ,i);
  621.              type_of(l) == t_cons;
  622.              l = l->c.c_cdr) {
  623.             y = find_symbol(l->c.c_car, p);
  624.             if (intern_flag && l->c.c_car != y
  625.                 && ! member_eq(y,p->p.p_shadowings)
  626.                 )
  627. FEerror("Cannot use ~S~%\
  628. from ~S,~%\
  629. because ~S and ~S will cause~%\
  630. a name conflict.", 4, x, p, l->c.c_car, y);
  631.         }
  632.     p->p.p_uselist = make_cons(x, p->p.p_uselist);
  633.     x->p.p_usedbylist = make_cons(p, x->p.p_usedbylist);
  634. }
  635.  
  636. unuse_package(x0, p)
  637. object x0, p;
  638. {
  639.     object x = x0;
  640.  
  641.     if (type_of(x) != t_package) {
  642.         x = find_package(x);
  643.         if (x == Cnil)
  644.             no_package(x0);
  645.     }
  646.     delete_eq(x, &p->p.p_uselist);
  647.     delete_eq(p, &x->p.p_usedbylist);
  648. }
  649.  
  650. @(defun make_package (pack_name
  651.               &key nicknames
  652.                (use `make_cons(lisp_package, Cnil)`)
  653.               (internal `small_fixnum(0)`)
  654.               (external `small_fixnum(0)`)
  655.               )
  656. @
  657.     check_type_or_string_symbol(&pack_name);
  658.     @(return `make_package(pack_name, nicknames, use,
  659.                    fix(internal),fix(external))`)
  660. @)
  661.  
  662. @(defun in_package (pack_name &key nicknames (use Cnil use_sp)
  663.               (internal `small_fixnum(0)`)
  664.               (external `small_fixnum(0)`)
  665.             )
  666. @
  667.     check_type_or_string_symbol(&pack_name);
  668.     if (find_package(pack_name) == Cnil && !(use_sp))
  669.         use = make_cons(lisp_package, Cnil);
  670.     @(return `in_package(pack_name, nicknames, use,fix(internal),fix(external))`)
  671. @)
  672.  
  673. Lfind_package()
  674. {
  675.     check_arg(1);
  676.  
  677.     vs_base[0] = find_package(vs_base[0]);
  678. }
  679.  
  680. Lpackage_name()
  681. {
  682.     check_arg(1);
  683.  
  684.     check_type_package(&vs_base[0]);
  685.     vs_base[0] = vs_base[0]->p.p_name;
  686. }
  687.  
  688. Lpackage_nicknames()
  689. {
  690.     check_arg(1);
  691.  
  692.     check_type_or_symbol_string_package(&vs_base[0]);
  693.     vs_base[0] = coerce_to_package(vs_base[0]);
  694.     vs_base[0] = vs_base[0]->p.p_nicknames;
  695. }
  696.  
  697. @(defun rename_package (pack new_name &o new_nicknames)
  698. @
  699.     check_type_or_symbol_string_package(&pack);
  700.     pack = coerce_to_package(pack);
  701.     check_type_or_string_symbol(&new_name);
  702.     @(return `rename_package(pack, new_name, new_nicknames)`)
  703. @)
  704.  
  705. Lpackage_use_list()
  706. {
  707.     check_arg(1);
  708.  
  709.     check_type_or_symbol_string_package(&vs_base[0]);
  710.     vs_base[0] = coerce_to_package(vs_base[0]);
  711.     vs_base[0] = vs_base[0]->p.p_uselist;
  712. }
  713.  
  714. Lpackage_used_by_list()
  715. {
  716.     check_arg(1);
  717.  
  718.     check_type_or_symbol_string_package(&vs_base[0]);
  719.     vs_base[0] = coerce_to_package(vs_base[0]);
  720.     vs_base[0] = vs_base[0]->p.p_usedbylist;
  721. }
  722.  
  723. Lpackage_shadowing_symbols()
  724. {
  725.     check_arg(1);
  726.  
  727.     check_type_or_symbol_string_package(&vs_base[0]);
  728.     vs_base[0] = coerce_to_package(vs_base[0]);
  729.     vs_base[0] = vs_base[0]->p.p_shadowings;
  730. }
  731.  
  732. Llist_all_packages()
  733. {
  734.     struct package *p;
  735.     int i;
  736.  
  737.     check_arg(0);
  738.     for (p = pack_pointer, i = 0;  p != NULL;  p = p->p_link, i++)
  739.         vs_push((object)p);
  740.     vs_push(Cnil);
  741.     while (i-- > 0)
  742.         stack_cons();
  743. }
  744.  
  745. @(defun intern (strng &optional (p `current_package()`) &aux sym)
  746. @
  747.     check_type_string(&strng);
  748.     check_type_or_symbol_string_package(&p);
  749.     p = coerce_to_package(p);
  750.     sym = intern(strng, p);
  751.     if (intern_flag == INTERNAL)
  752.         @(return sym Kinternal)
  753.     if (intern_flag == EXTERNAL)
  754.         @(return sym Kexternal)
  755.     if (intern_flag == INHERITED)
  756.         @(return sym Kinherited)
  757.     @(return sym Cnil)
  758. @)
  759.  
  760. @(defun find_symbol (strng &optional (p `current_package()`))
  761.     object x;
  762. @
  763.     check_type_string(&strng);
  764.     check_type_or_symbol_string_package(&p);
  765.     p = coerce_to_package(p);
  766.     x = find_symbol(strng, p);
  767.     if (intern_flag == INTERNAL)
  768.         @(return x Kinternal)
  769.     if (intern_flag == EXTERNAL)
  770.         @(return x Kexternal)
  771.     if (intern_flag == INHERITED)
  772.         @(return x Kinherited)
  773.     @(return Cnil Cnil)
  774. @)
  775.  
  776. @(defun unintern (symbl &optional (p `current_package()`))
  777.     object x;
  778. @
  779.     check_type_symbol(&symbl);
  780.     check_type_or_symbol_string_package(&p);
  781.     p = coerce_to_package(p);
  782.     if (unintern(symbl, p))
  783.         @(return Ct)
  784.     else
  785.         @(return Cnil)
  786. @)
  787.  
  788. @(defun export (symbols &o (pack `current_package()`))
  789.     object l;
  790. @
  791.     check_type_or_symbol_string_package(&pack);
  792.     pack = coerce_to_package(pack);
  793. BEGIN:
  794.     switch (type_of(symbols)) {
  795.     case t_symbol:
  796.         if (symbols == Cnil)
  797.             break;
  798.         export(symbols, pack);
  799.         break;
  800.  
  801.     case t_cons:
  802.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  803.             export(l->c.c_car, pack);
  804.         break;
  805.  
  806.     default:
  807.         check_type_symbol(&symbols);
  808.         goto BEGIN;
  809.     }
  810.     @(return Ct)
  811. @)
  812.  
  813. @(defun unexport (symbols &o (pack `current_package()`))
  814.     object l;
  815. @
  816.     check_type_or_symbol_string_package(&pack);
  817.     pack = coerce_to_package(pack);
  818. BEGIN:
  819.     switch (type_of(symbols)) {
  820.     case t_symbol:
  821.         if (symbols == Cnil)
  822.             break;
  823.         unexport(symbols, pack);
  824.         break;
  825.  
  826.     case t_cons:
  827.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  828.             unexport(l->c.c_car, pack);
  829.         break;
  830.  
  831.     default:
  832.         check_type_symbol(&symbols);
  833.         goto BEGIN;
  834.     }
  835.     @(return Ct)
  836. @)
  837.  
  838. @(defun import (symbols &o (pack `current_package()`))
  839.     object l;
  840. @
  841.     check_type_or_symbol_string_package(&pack);
  842.     pack = coerce_to_package(pack);
  843. BEGIN:
  844.     switch (type_of(symbols)) {
  845.     case t_symbol:
  846.         if (symbols == Cnil)
  847.             break;
  848.         import(symbols, pack);
  849.         break;
  850.  
  851.     case t_cons:
  852.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  853.             import(l->c.c_car, pack);
  854.         break;
  855.  
  856.     default:
  857.         check_type_symbol(&symbols);
  858.         goto BEGIN;
  859.     }
  860.     @(return Ct)
  861. @)
  862.  
  863. @(defun shadowing_import (symbols &o (pack `current_package()`))
  864.     object l;
  865. @
  866.     check_type_or_symbol_string_package(&pack);
  867.     pack = coerce_to_package(pack);
  868. BEGIN:
  869.     switch (type_of(symbols)) {
  870.     case t_symbol:
  871.         if (symbols == Cnil)
  872.             break;
  873.         shadowing_import(symbols, pack);
  874.         break;
  875.  
  876.     case t_cons:
  877.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  878.             shadowing_import(l->c.c_car, pack);
  879.         break;
  880.  
  881.     default:
  882.         check_type_symbol(&symbols);
  883.         goto BEGIN;
  884.     }
  885.     @(return Ct)
  886. @)
  887.  
  888. @(defun shadow (symbols &o (pack `current_package()`))
  889.     object l;
  890. @
  891.     check_type_or_symbol_string_package(&pack);
  892.     pack = coerce_to_package(pack);
  893. BEGIN:
  894.     switch (type_of(symbols)) {
  895.     case t_symbol:
  896.         if (symbols == Cnil)
  897.             break;
  898.         shadow(symbols, pack);
  899.         break;
  900.  
  901.     case t_cons:
  902.         for (l = symbols;  !endp(l);  l = l->c.c_cdr)
  903.             shadow(l->c.c_car, pack);
  904.         break;
  905.  
  906.     default:
  907.         check_type_symbol(&symbols);
  908.         goto BEGIN;
  909.     }
  910.     @(return Ct)
  911. @)
  912.  
  913. @(defun use_package (pack &o (pa `current_package()`))
  914.     object l;
  915. @
  916.     check_type_or_symbol_string_package(&pa);
  917.     pa = coerce_to_package(pa);
  918. BEGIN:
  919.     switch (type_of(pack)) {
  920.     case t_symbol:
  921.         if (pack == Cnil)
  922.             break;
  923.  
  924.     case t_string:
  925.     case t_package:
  926.         use_package(pack, pa);
  927.         break;
  928.  
  929.     case t_cons:
  930.         for (l = pack;  !endp(l);  l = l->c.c_cdr)
  931.             use_package(l->c.c_car, pa);
  932.         break;
  933.  
  934.     default:
  935.         check_type_package(&pack);
  936.         goto BEGIN;
  937.     }
  938.     @(return Ct)
  939. @)
  940.  
  941. @(defun unuse_package (pack &o (pa `current_package()`))
  942.     object l;
  943. @
  944.     check_type_or_symbol_string_package(&pa);
  945.     pa = coerce_to_package(pa);
  946. BEGIN:
  947.     switch (type_of(pack)) {
  948.     case t_symbol:
  949.         if (pack == Cnil)
  950.             break;
  951.  
  952.     case t_string:
  953.     case t_package:
  954.         unuse_package(pack, pa);
  955.         break;
  956.  
  957.     case t_cons:
  958.         for (l = pack;  !endp(l);  l = l->c.c_cdr)
  959.             unuse_package(l->c.c_car, pa);
  960.         break;
  961.  
  962.     default:
  963.         check_type_package(&pack);
  964.         goto BEGIN;
  965.     }
  966.     @(return Ct)
  967. @)
  968.  
  969. siLpackage_internal()
  970. {
  971.     int j;
  972.  
  973.     check_arg(2);
  974.     check_type_package(&vs_base[0]);
  975.     if (type_of(vs_base[1]) != t_fixnum ||
  976.         (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_internal_size)
  977.         FEerror("~S is an illgal index to a package hashtable.",
  978.             1, vs_base[1]);
  979.     vs_base[0] = P_INTERNAL(vs_base[0],j);
  980.     vs_pop;
  981. }
  982.  
  983. siLpackage_external()
  984. {
  985.     int j;
  986.  
  987.     check_arg(2);
  988.     check_type_package(&vs_base[0]);
  989.     if (type_of(vs_base[1]) != t_fixnum ||
  990.         (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_external_size)
  991.         FEerror("~S is an illegal index to a package hashtable.",
  992.             1, vs_base[1]);
  993.     vs_base[0] = P_EXTERNAL(vs_base[0],j);
  994.     vs_pop;
  995. }
  996.  
  997. no_package(n)
  998. object n;
  999. {
  1000.     FEerror("There is no package with the name ~A.", 1, n);
  1001. }
  1002.  
  1003. package_already(n)
  1004. object n;
  1005. {
  1006.     FEerror("A package with the name ~A already exists.", 1, n);
  1007. }
  1008.  
  1009. void
  1010. siLpackage_size()
  1011. {object p;
  1012.  p=vs_base[0];
  1013.  check_type_package(&p);
  1014.  check_arg(1);
  1015.  vs_base[0]=make_fixnum(p->p.p_external_size);
  1016.  vs_base[1]=make_fixnum(p->p.p_internal_size);
  1017.  vs_top=vs_base+2;
  1018.  return;
  1019. }
  1020.  
  1021.  
  1022. init_package()
  1023. {
  1024.  
  1025.     lisp_package
  1026.     = make_package(make_simple_string("LISP"),
  1027.                Cnil, Cnil,47,509);
  1028.     user_package
  1029.     = make_package(make_simple_string("USER"),
  1030.                Cnil,
  1031.                make_cons(lisp_package, Cnil),509,97);
  1032.     keyword_package
  1033.     = make_package(make_simple_string("KEYWORD"),
  1034.                Cnil, Cnil,11,509);
  1035.     system_package
  1036.     = make_package(make_simple_string("SYSTEM"),
  1037.                make_cons(make_simple_string("SI"),
  1038.                      make_cons(make_simple_string("SYS"),
  1039.                        Cnil)),
  1040.                make_cons(lisp_package, Cnil),251,157);
  1041.  
  1042.     /*  There is no need to enter a package as a mark origin.  */
  1043.  
  1044.     Vpackage = make_special("*PACKAGE*", lisp_package);
  1045.  
  1046.     Kinternal = make_keyword("INTERNAL");
  1047.     Kexternal = make_keyword("EXTERNAL");
  1048.     Kinherited = make_keyword("INHERITED");
  1049.     Knicknames = make_keyword("NICKNAMES");
  1050.     Kuse = make_keyword("USE");
  1051.  
  1052.     uninterned_list = Cnil;
  1053.     enter_mark_origin(&uninterned_list);
  1054. }
  1055.  
  1056. init_package_function()
  1057. {
  1058.     make_function("MAKE-PACKAGE", Lmake_package);
  1059.     make_function("IN-PACKAGE", Lin_package);
  1060.     make_function("FIND-PACKAGE", Lfind_package);
  1061.     make_function("PACKAGE-NAME", Lpackage_name);
  1062.     make_function("PACKAGE-NICKNAMES", Lpackage_nicknames);
  1063.     make_function("RENAME-PACKAGE", Lrename_package);
  1064.     make_function("PACKAGE-USE-LIST", Lpackage_use_list);
  1065.     make_function("PACKAGE-USED-BY-LIST", Lpackage_used_by_list);
  1066.     make_function("PACKAGE-SHADOWING-SYMBOLS",
  1067.               Lpackage_shadowing_symbols);
  1068.     make_function("LIST-ALL-PACKAGES", Llist_all_packages);
  1069.     make_function("INTERN", Lintern);
  1070.     make_function("FIND-SYMBOL", Lfind_symbol);
  1071.     make_function("UNINTERN", Lunintern);
  1072.     make_function("EXPORT", Lexport);
  1073.     make_function("UNEXPORT", Lunexport);
  1074.     make_function("IMPORT", Limport);
  1075.     make_function("SHADOWING-IMPORT", Lshadowing_import);
  1076.     make_function("SHADOW", Lshadow);
  1077.     make_function("USE-PACKAGE", Luse_package);
  1078.     make_function("UNUSE-PACKAGE", Lunuse_package);
  1079.  
  1080.     make_si_function("PACKAGE-SIZE",siLpackage_size);
  1081.     make_si_function("PACKAGE-INTERNAL", siLpackage_internal);
  1082.     make_si_function("PACKAGE-EXTERNAL", siLpackage_external);
  1083. }
  1084.